home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / ratfor.arc / RATFOR.C < prev    next >
C/C++ Source or Header  |  1986-09-01  |  34KB  |  1,552 lines
  1. /*
  2.  * ratfor
  3.  *
  4.  * A ratfor pre-processor in C. It is almost a direct
  5.  * translation of a pre-processor distributed by the
  6.  * University of Arizona. It closely corresponds to the
  7.  * pre-processor described in the "SOFTWARE TOOLS" book.
  8.  * It lacks the "case" construct available in the UNIX
  9.  * version of ratfor.
  10.  *
  11.  * By:  Oz
  12.  *      March 1984
  13.  *
  14.  */
  15. #include "\c86\include\stdio.h"
  16. #include "\c86\include\ratdef.h"
  17. #include "\c86\include\ratcom.h"
  18.  
  19. /* keywords: */
  20.  
  21. char sdo[3] = {
  22.     LETD,LETO,EOS};
  23. char vdo[2] = {
  24.     LEXDO,EOS};
  25.  
  26. char sif[3] = {
  27.     LETI,LETF,EOS};
  28. char vif[2] = {
  29.     LEXIF,EOS};
  30.  
  31. char selse[5] = {
  32.     LETE,LETL,LETS,LETE,EOS};
  33. char velse[2] = {
  34.     LEXELSE,EOS};
  35.  
  36. char swhile[6] = {
  37.     LETW, LETH, LETI, LETL, LETE, EOS};
  38. char vwhile[2] = {
  39.     LEXWHILE, EOS};
  40.  
  41. char sbreak[6] = {
  42.     LETB, LETR, LETE, LETA, LETK, EOS};
  43. char vbreak[2] = {
  44.     LEXBREAK, EOS};
  45.  
  46. char snext[5] = {
  47.     LETN,LETE, LETX, LETT, EOS};
  48. char vnext[2] = {
  49.     LEXNEXT, EOS};
  50.  
  51. char sfor[4] = {
  52.     LETF,LETO, LETR, EOS};
  53. char vfor[2] = {
  54.     LEXFOR, EOS};
  55.  
  56. char srept[7] = {
  57.     LETR, LETE, LETP, LETE, LETA, LETT, EOS};
  58. char vrept[2] = {
  59.     LEXREPEAT, EOS};
  60.  
  61. char suntil[6] = {
  62.     LETU, LETN, LETT, LETI, LETL, EOS};
  63. char vuntil[2] = {
  64.     LEXUNTIL, EOS};
  65.  
  66. char sret[7] = {
  67.     LETR, LETE, LETT, LETU, LETR, LETN, EOS};
  68. char vret[2] = {
  69.     LEXRETURN, EOS};
  70.  
  71. char sstr[7] = {
  72.     LETS, LETT, LETR, LETI, LETN, LETG, EOS};
  73. char vstr[2] = {
  74.     LEXSTRING, EOS};
  75. char deftyp[2] = {
  76.     DEFTYPE, EOS};
  77.  
  78. /* constant strings */
  79.  
  80. char *errmsg = "error at line ";
  81. char *in     = " in ";
  82. char *ifnot  = "if(.not.";
  83. char *incl   = "include";
  84. char *fncn   = "function";
  85. char *def    = "define";
  86. char *bdef   = "DEFINE";
  87. char *contin = "continue";
  88. char *rgoto  = "goto ";
  89. char *dat    = "data ";
  90. char *eoss   = "EOS/";
  91.  
  92. extern char ngetch();
  93.  
  94. /* ------------------------------ */
  95. /* M A I N   L I N E  &  I N I T  */
  96. /* ------------------------------ */
  97.  
  98. main(argc,argv)
  99. int argc;
  100. char *argv[];
  101. {
  102.     int i;
  103.     char *p;
  104.  
  105.     if (argc == 1)
  106.         usage();
  107.     if ((infile[0] = fopen(argv[1], "r")) == NULL) {
  108.         fprintf(stderr,"%s: cannot open.\n",argv[1]);
  109.         exit(1);
  110.     }
  111.     if (p = argv[2])
  112.         if ((freopen(p, "w", stdout)) == NULL) {
  113.             fprintf(stderr,"%s: cannot create.\n",p);
  114.             exit(1);
  115.         }
  116.  
  117.  /*
  118.  * initialize our stuff..
  119.  *
  120.  */
  121.     outp = 0;               /* output character pointer */
  122.     level = 0;              /* file control */
  123.     linect[0] = 1;          /* line count of first file */
  124.     fnamp = 0;
  125.     fnames[0] = EOS;
  126.     bp = -1;                /* pushback buffer pointer */
  127.     fordep = 0;             /* for stack */
  128.     for( i = 0; i <= 126; i++)
  129.         tabptr[i] = 0;
  130.     install(def, deftyp);   /* default definitions */
  131.     install(bdef, deftyp);
  132.     fcname[0] = EOS;        /* current function name */
  133.     label = 23000;          /* next generated label */
  134.  
  135.     parse();                /* call parser.. */
  136.     exit(1);
  137. }
  138.  
  139.  
  140. /* ------------------------------ */
  141. /* P A R S E R                    */
  142. /* ------------------------------ */
  143.  
  144. parse()
  145. {
  146.     char lexstr[MAXTOK];
  147.     int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, token;
  148.  
  149.     sp = 0;
  150.     lextyp[0] = EOF;
  151.     for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
  152.         if (token == LEXIF)
  153.             ifcode(&lab);
  154.         else if (token == LEXDO)
  155.             docode(&lab);
  156.         else if (token == LEXWHILE)
  157.             whilec(&lab);
  158.         else if (token == LEXFOR)
  159.             forcod(&lab);
  160.         else if (token == LEXREPEAT)
  161.             repcod(&lab);
  162.         else if (token == LEXDIGITS)
  163.             labelc(lexstr);
  164.         else if (token == LEXELSE) {
  165.             if (lextyp[sp] == LEXIF)
  166.                 elseif(labval[sp]);
  167.             else
  168.                 synerr("illegal else.");
  169.         }
  170.         if (token == LEXIF || token == LEXELSE || token == LEXWHILE
  171.             || token == LEXFOR || token == LEXREPEAT
  172.             || token == LEXDO || token == LEXDIGITS 
  173.             || token == LBRACE) {
  174.             sp++;         /* beginning of statement */
  175.             if (sp > MAXSTACK)
  176.                 baderr("stack overflow in parser.");
  177.             lextyp[sp] = token;     /* stack type and value */
  178.             labval[sp] = lab;
  179.         }
  180.         else {      /* end of statement - prepare to unstack */
  181.             if (token == RBRACE) {
  182.                 if (lextyp[sp] == LBRACE)
  183.                     sp--;
  184.                 else
  185.                     synerr("illegal right brace.");
  186.             }
  187.             else if (token == LEXOTHER)
  188.                 otherc(lexstr);
  189.             else if (token == LEXBREAK || token == LEXNEXT)
  190.                 brknxt(sp, lextyp, labval, token);
  191.             else if (token == LEXRETURN)
  192.                 retcod();
  193.             else if (token == LEXSTRING)
  194.                 strdcl();
  195.             token = lex(lexstr);      /* peek at next token */
  196.             pbstr(lexstr);
  197.             unstak(&sp, lextyp, labval, token);
  198.         }
  199.     }
  200.     if (sp != 0)
  201.         synerr("unexpected EOF.");
  202. }
  203.  
  204.  
  205. /* ------------------------------ */
  206. /* L E X I C A L  A N A L Y S E R */
  207. /* ------------------------------ */
  208.  
  209. /*
  210.  *  alldig - return YES if str is all digits
  211.  *
  212.  */
  213. int
  214. alldig(str)
  215. char str[];
  216. {
  217.     int i,j;
  218.  
  219.     j = NO;
  220.     if (str[0] == EOS)
  221.         return(j);
  222.     for (i = 0; str[i] != EOS; i++)
  223.         if (type(str[i]) != DIGIT)
  224.             return(j);
  225.     j = YES;
  226.     return(j);
  227. }
  228.  
  229.  
  230. /*
  231.  * balpar - copy balanced paren string
  232.  *
  233.  */
  234. balpar()
  235. {
  236.     char token[MAXTOK];
  237.     int t,nlpar;
  238.  
  239.     if (gnbtok(token, MAXTOK) != LPAREN) {
  240.         synerr("missing left paren.");
  241.         return;
  242.     }
  243.     outstr(token);
  244.     nlpar = 1;
  245.     do {
  246.         t = gettok(token, MAXTOK);
  247.         if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
  248.             pbstr(token);
  249.             break;
  250.         }
  251.         if (t == NEWLINE)      /* delete newlines */
  252.             token[0] = EOS;
  253.         else if (t == LPAREN)
  254.             nlpar++;
  255.         else if (t == RPAREN)
  256.             nlpar--;
  257.         /* else nothing special */
  258.         outstr(token);
  259.     } 
  260.     while (nlpar > 0);
  261.     if (nlpar != 0)
  262.         synerr("missing parenthesis in condition.");
  263. }
  264.  
  265. /*
  266.  * deftok - get token; process macro calls and invocations
  267.  *
  268.  */
  269. int
  270. deftok(token, toksiz, fd)
  271. char token[];
  272. int toksiz;
  273. FILE *fd;
  274. {
  275.     char defn[MAXDEF];
  276.     int t;
  277.  
  278.     for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
  279.         if (t != ALPHA)   /* non-alpha */
  280.             break;
  281.         if (look(token, defn) == NO)   /* undefined */
  282.             break;
  283.         if (defn[0] == DEFTYPE) {   /* get definition */
  284.             getdef(token, toksiz, defn, MAXDEF, fd);
  285.             install(token, defn);
  286.         }
  287.         else
  288.             pbstr(defn);   /* push replacement onto input */
  289.     }
  290.     if (t == ALPHA)   /* convert to single case */
  291.         fold(token);
  292.     return(t);
  293. }
  294.  
  295.  
  296. /*
  297.  * eatup - process rest of statement; interpret continuations
  298.  *
  299.  */
  300. eatup()
  301. {
  302.  
  303.     char ptoken[MAXTOK], token[MAXTOK];
  304.     int nlpar, t;
  305.  
  306.     nlpar = 0;
  307.     do {
  308.         t = gettok(token, MAXTOK);
  309.         if (t == SEMICOL || t == NEWLINE)
  310.             break;
  311.         if (t == RBRACE || t == LBRACE) {
  312.             pbstr(token);
  313.             break;
  314.         }
  315.         if (t == EOF) {
  316.             synerr("unexpected EOF.");
  317.             pbstr(token);
  318.             break;
  319.         }
  320.         if (t == COMMA || t == PLUS 
  321.             || t == MINUS || t == STAR || t == LPAREN
  322.             || t == AND || t == BAR || t == BANG
  323.             || t == EQUALS || t == UNDERLINE ) {
  324.             while (gettok(ptoken, MAXTOK) == NEWLINE)
  325.                 ;
  326.             pbstr(ptoken);
  327.             if (t == UNDERLINE)
  328.                 token[0] = EOS;
  329.         }
  330.         if (t == LPAREN)
  331.             nlpar++;
  332.         else if (t == RPAREN)
  333.             nlpar--;
  334.         outstr(token);
  335.  
  336.     } 
  337.     while (nlpar >= 0);
  338.  
  339.     if (nlpar != 0)
  340.         synerr("unbalanced parentheses.");
  341. }
  342.  
  343. /*
  344.  * getdef (for no arguments) - get name and definition
  345.  *
  346.  */
  347. getdef(token, toksiz, defn, defsiz, fd)
  348. char token[];
  349. int toksiz;
  350. char defn[];
  351. int defsiz;
  352. FILE *fd;
  353. {
  354.     int i, nlpar, t;
  355.     char c, ptoken[MAXTOK];
  356.  
  357.     skpblk(fd);
  358.     /*
  359.          * define(name,defn) or
  360.          * define name defn
  361.          *
  362.          */
  363.     if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {
  364.         ;
  365.         t = BLANK;              /* define name defn */
  366.         pbstr(ptoken);
  367.     }
  368.     skpblk(fd);
  369.     if (gtok(token, toksiz, fd) != ALPHA)
  370.         baderr("non-alphanumeric name.");
  371.     skpblk(fd);
  372.     c = (char) gtok(ptoken, MAXTOK, fd);
  373.     if (t == BLANK) {         /* define name defn */
  374.         pbstr(ptoken);
  375.         i = 0;
  376.         do {
  377.             c = ngetch(&c, fd);
  378.             if (i > defsiz)
  379.                 baderr("definition too long.");
  380.             defn[i++] = c;
  381.         } 
  382.         while (c != SHARP && c != NEWLINE && c != EOF);
  383.         if (c == SHARP)
  384.             putbak(c);
  385.     }
  386.     else if (t == LPAREN) {   /* define (name, defn) */
  387.         if (c != COMMA)
  388.             baderr("missing comma in define.");
  389.         /* else got (name, */
  390.         nlpar = 0;
  391.         for (i = 0; nlpar >= 0; i++)
  392.             if (i > defsiz)
  393.                 baderr("definition too long.");
  394.             else if (ngetch(&defn[i], fd) == EOF)
  395.                 baderr("missing right paren.");
  396.             else if (defn[i] == LPAREN)
  397.                 nlpar++;
  398.             else if (defn[i] == RPAREN)
  399.                 nlpar--;
  400.         /* else normal character in defn[i] */
  401.     }
  402.     else
  403.         baderr("getdef is confused.");
  404.     defn[i-1] = EOS;
  405. }
  406.  
  407. /*
  408.  * gettok - get token. handles file inclusion and line numbers
  409.  *
  410.  */
  411. int
  412. gettok(token, toksiz)
  413. char token[];
  414. int toksiz;
  415. {
  416.     int t, i;
  417.     int tok;
  418.     char name[MAXNAME];
  419.  
  420.     for ( ; level >= 0; level--) {
  421.         for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
  422.                      tok = deftok(token, toksiz, infile[level])) {
  423.                 if (equal(token, fncn) == YES) {
  424.                 skpblk(infile[level]);
  425.                 t = deftok(fcname, MAXNAME, infile[level]);
  426.                 pbstr(fcname);
  427.                 if (t != ALPHA)
  428.                     synerr("missing function name.");
  429.                 putbak(BLANK);
  430.                 return(tok);
  431.             }
  432.             else if (equal(token, incl) == NO)
  433.                 return(tok);
  434.             for (i = 0 ;; i = strlen(name)) {
  435.                 t = deftok(&name[i], MAXNAME, infile[level]);
  436.                 if (t == NEWLINE || t == SEMICOL) {
  437.                     pbstr(&name[i]);
  438.                     break;
  439.                 }
  440.             }
  441.             name[i] = EOS;
  442.             if (name[1] == SQUOTE) {
  443.                 outtab();
  444.                 outstr(token);
  445.                 outstr(name);
  446.                 outdon();
  447.                 eatup();
  448.                 return(tok);
  449.             }
  450.             if (level >= NFILES)
  451.                 synerr("includes nested too deeply.");
  452.             else {
  453.                 infile[level+1] = fopen(name, "r");
  454.                 linect[level+1] = 1;
  455.                 if (infile[level+1] == NULL)
  456.                     synerr("can't open include.");
  457.                 else {
  458.                     level++;
  459.                     if (fnamp + i <= MAXFNAMES) {
  460.                         scopy(name, 0, fnames, fnamp);
  461.                         fnamp = fnamp + i;    /* push file name stack */
  462.                     }
  463.                 }
  464.             }
  465.         }
  466.         if (level > 0) {      /* close include and pop file name stack */
  467.             fclose(infile[level]);
  468.             for (fnamp--; fnamp > 0; fnamp--)
  469.                 if (fnames[fnamp-1] == EOS)
  470.                     break;
  471.         }
  472.     }
  473.     token[0] = EOF;   /* in case called more than once */
  474.     token[1] = EOS;
  475.     tok = EOF;
  476.     return(tok);
  477. }
  478.  
  479. /*
  480.  * gnbtok - get nonblank token
  481.  *
  482.  */
  483. int
  484. gnbtok(token, toksiz)
  485. char token[];
  486. int toksiz;
  487. {
  488.     int tok;
  489.  
  490.     skpblk(infile[level]);
  491.     tok = gettok(token, toksiz);
  492.     return(tok);
  493. }
  494.  
  495. /*
  496.  * gtok - get token for Ratfor
  497.  *
  498.  */
  499. int
  500. gtok(lexstr, toksiz, fd)
  501. char lexstr[];
  502. int toksiz;
  503. FILE *fd;
  504. {
  505.     int i, b, n, tok; 
  506.     char c;
  507.     c = ngetch(&lexstr[0], fd);
  508.     if (c == BLANK || c == TAB) {
  509.         lexstr[0] = BLANK;
  510.         while (c == BLANK || c == TAB)    /* compress many blanks to one */
  511.             c = ngetch(&c, fd);
  512.         if (c == SHARP)
  513.             while (ngetch(&c, fd) != NEWLINE)   /* strip comments */
  514.                 ;
  515.         if (c != NEWLINE)
  516.             putbak(c);
  517.         else
  518.             lexstr[0] = NEWLINE;
  519.         lexstr[1] = EOS;
  520.         return((int)lexstr[0]);
  521.     }
  522.     i = 0;
  523.     tok = type(c);
  524.     if (tok == LETTER) {    /* alpha */
  525.         for (i = 0; i < toksiz - 3; i++) {
  526.             tok = type(ngetch(&lexstr[i+1], fd));
  527.             /* Test for DOLLAR added by BM, 7-15-80 */
  528.             if (tok != LETTER && tok != DIGIT 
  529.                 && tok != UNDERLINE && tok!=DOLLAR
  530.                 && tok != PERIOD)
  531.                 break;
  532.         }
  533.         putbak(lexstr[i+1]);
  534.         tok = ALPHA;
  535.     }
  536.     else if (tok == DIGIT) {        /* digits */
  537.         b = c - DIG0;   /* in case alternate base number */
  538.         for (i = 0; i < toksiz - 3; i++) {
  539.             if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
  540.                 break;
  541.             b = 10*b + lexstr[i+1] - DIG0;
  542.         }
  543.         if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {   
  544.             /* n%ddd... */
  545.             for (n = 0;; n = b*n + c - DIG0) {
  546.                 c = ngetch(&lexstr[0], fd);
  547.                 if (c >= LETA && c <= LETZ)
  548.                     c = c - LETA + DIG9 + 1;
  549.                 else if (c >= BIGA && c <= BIGZ)
  550.                     c = c - BIGA + DIG9 + 1;
  551.                 if (c < DIG0 || c >= DIG0 + b)
  552.                     break;
  553.             }
  554.             putbak(lexstr[0]);
  555.             i = itoc(n, lexstr, toksiz);
  556.         }
  557.         else
  558.             putbak(lexstr[i+1]);
  559.         tok = DIGIT;
  560.     }
  561. #ifdef SQUAREB
  562.     else if (c == LBRACK) {   /* allow [ for { */
  563.         lexstr[0] = LBRACE;
  564.         tok = LBRACE;
  565.     }
  566.     else if (c == RBRACK) {   /* allow ] for } */
  567.         lexstr[0] = RBRACE;
  568.         tok = RBRACE;
  569.     }
  570. #endif
  571.     else if (c == SQUOTE || c == DQUOTE) {
  572.         for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
  573.             if (lexstr[i] == UNDERLINE)
  574.                 if (ngetch(&c, fd) == NEWLINE) {
  575.                     while (c == NEWLINE || c == BLANK || c == TAB)
  576.                         c = ngetch(&c, fd);
  577.                     lexstr[i] = c;
  578.                 }
  579.             else
  580.                 putbak(c);
  581.             if (lexstr[i] == NEWLINE || i >= toksiz-1) {
  582.                 synerr("missing quote.");
  583.                 lexstr[i] = lexstr[0];
  584.                 putbak(NEWLINE);
  585.                 break;
  586.             }
  587.         }
  588.     }
  589.     else if (c == SHARP) {   /* strip comments */
  590.         while (ngetch(&lexstr[0], fd) != NEWLINE)
  591.             ;
  592.         tok = NEWLINE;
  593.     }
  594.     else if (c == GREATER || c == LESS || c == NOT 
  595.         || c == BANG || c == CARET || c == EQUALS 
  596.         || c == AND || c == OR)
  597.         i = relate(lexstr, fd);
  598.     if (i >= toksiz-1)
  599.         synerr("token too long.");
  600.     lexstr[i+1] = EOS;
  601.     if (lexstr[0] == NEWLINE)
  602.         linect[level] = linect[level] + 1;
  603.     return(tok);
  604. }
  605.  
  606. /*
  607.  * lex - return lexical type of token
  608.  *
  609.  */
  610. int
  611. lex(lexstr)
  612. char lexstr[];
  613. {
  614.  
  615.     int tok;
  616.  
  617.     for (tok = gnbtok(lexstr, MAXTOK);
  618.              tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
  619.             ;
  620.     if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
  621.         return(tok);
  622.     if (tok == DIGIT)
  623.         tok = LEXDIGITS;
  624.     else if (equal(lexstr, sif) == YES)
  625.         tok = vif[0];
  626.     else if (equal(lexstr, selse) == YES)
  627.         tok = velse[0];
  628.     else if (equal(lexstr, swhile) == YES)
  629.         tok = vwhile[0];
  630.     else if (equal(lexstr, sdo) == YES)
  631.         tok = vdo[0];
  632.     else if (equal(lexstr, sbreak) == YES)
  633.         tok = vbreak[0];
  634.     else if (equal(lexstr, snext) == YES)
  635.         tok = vnext[0];
  636.     else if (equal(lexstr, sfor) == YES)
  637.         tok = vfor[0];
  638.     else if (equal(lexstr, srept) == YES)
  639.         tok = vrept[0];
  640.     else if (equal(lexstr, suntil) == YES)
  641.         tok = vuntil[0];
  642.     else if (equal(lexstr, sret) == YES)
  643.         tok = vret[0];
  644.     else if (equal(lexstr, sstr) == YES)
  645.         tok = vstr[0];
  646.     else
  647.         tok = LEXOTHER;
  648.     return(tok);
  649. }
  650.  
  651. /*
  652.  * ngetch - get a (possibly pushed back) character
  653.  *
  654.  */
  655. char
  656. ngetch(c, fd)
  657. char *c;
  658. FILE *fd;
  659. {
  660.  
  661.     if (bp >= 0) {
  662.         *c = buf[bp];
  663.         bp--;
  664.     }
  665.     else
  666.         *c = (char) getc(fd);
  667.  
  668.     return(*c);
  669. }
  670. /*
  671.  * pbstr - push string back onto input
  672.  *
  673.  */
  674. pbstr(in)
  675. char in[];
  676. {
  677.     int i;
  678.  
  679.     for (i = strlen(in) - 1; i >= 0; i--)
  680.         putbak(in[i]);
  681. }
  682.  
  683. /*
  684.  * putbak - push char back onto input
  685.  *
  686.  */
  687. putbak(c)
  688. char c;
  689. {
  690.  
  691.     bp++;
  692.     if (bp > BUFSIZE)
  693.         baderr("too many characters pushed back.");
  694.     buf[bp] = c;
  695. }
  696.  
  697.  
  698. /*
  699.  * relate - convert relational shorthands into long form
  700.  *
  701.  */
  702. int
  703. relate(token, fd)
  704. char token[];
  705. FILE *fd;
  706. {
  707.  
  708.     if (ngetch(&token[1], fd) != EQUALS) {
  709.         putbak(token[1]);
  710.         token[2] = LETT;
  711.     }
  712.     else
  713.         token[2] = LETE;
  714.     token[3] = PERIOD;
  715.     token[4] = EOS;
  716.     token[5] = EOS; /* for .not. and .and. */
  717.     if (token[0] == GREATER)
  718.         token[1] = LETG;
  719.     else if (token[0] == LESS)
  720.         token[1] = LETL;
  721.     else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
  722.         if (token[1] != EQUALS) {
  723.             token[2] = LETO;
  724.             token[3] = LETT;
  725.             token[4] = PERIOD;
  726.         }
  727.         token[1] = LETN;
  728.     }
  729.     else if (token[0] == EQUALS) {
  730.         if (token[1] != EQUALS) {
  731.             token[2] = EOS;
  732.             return(0);
  733.         }
  734.         token[1] = LETE;
  735.         token[2] = LETQ;
  736.     }
  737.     else if (token[0] == AND) {
  738.         token[1] = LETA;
  739.         token[2] = LETN;
  740.         token[3] = LETD;
  741.         token[4] = PERIOD;
  742.     }
  743.     else if (token[0] == OR) {
  744.         token[1] = LETO;
  745.         token[2] = LETR;
  746.     }
  747.     else   /* can't happen */
  748.     token[1] = EOS;
  749.     token[0] = PERIOD;
  750.     return(strlen(token)-1);
  751. }
  752.  
  753. /*
  754.  * skpblk - skip blanks and tabs in file  fd
  755.  *
  756.  */
  757. skpblk(fd)
  758. FILE *fd;
  759. {
  760.     char c;
  761.  
  762.     for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
  763.         ;
  764.     putbak(c);
  765. }
  766.  
  767.  
  768. /* 
  769.  * type - return LETTER, DIGIT or char; works with ascii alphabet
  770.  *
  771.  */
  772. int
  773. type(c)
  774. char c;
  775. {
  776.     int t;
  777.  
  778.     if (c >= DIG0 && c <= DIG9)
  779.         t = DIGIT;
  780.     else if (c >= LETA && c <= LETZ)
  781.         t = LETTER;
  782.     else if (c >= BIGA && c <= BIGZ)
  783.         t = LETTER;
  784.     else
  785.         t = c;
  786.     return(t);
  787. }
  788.  
  789.  
  790. /* ------------------------------ */
  791. /* C O D E  G E N E R A T I O N   */
  792. /* ------------------------------ */
  793.  
  794. /*
  795.  * brknxt - generate code for break n and next n; n = 1 is default
  796.  *
  797.  */
  798. brknxt(sp, lextyp, labval, token)
  799. int sp;
  800. int lextyp[];
  801. int labval[];
  802. int token;
  803. {
  804.     int i, n;
  805.     char t, ptoken[MAXTOK];
  806.  
  807.     n = 0;
  808.     t = gnbtok(ptoken, MAXTOK);
  809.     if (alldig(ptoken) == YES) {     /* have break n or next n */
  810.         i = 0;
  811.         n = ctoi(ptoken, &i) - 1;
  812.     }
  813.     else if (t != SEMICOL)      /* default case */
  814.         pbstr(ptoken);
  815.     for (i = sp; i >= 0; i--)
  816.         if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
  817.             || lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
  818.             if (n > 0) {
  819.                 n--;
  820.                 continue;             /* seek proper level */
  821.             }
  822.             else if (token == LEXBREAK)
  823.                 outgo(labval[i]+1);
  824.             else
  825.                 outgo(labval[i]);
  826.             xfer = YES;
  827.             return;
  828.         }
  829.     if (token == LEXBREAK)
  830.         synerr("illegal break.");
  831.     else
  832.         synerr("illegal next.");
  833.     return;
  834. }
  835.  
  836. /*
  837.  * docode - generate code for beginning of do
  838.  *
  839.  */
  840. docode(lab)
  841. int *lab;
  842. {
  843.     xfer = NO;
  844.     outtab();
  845.     outstr(sdo);
  846.     *lab = labgen(2);
  847.     outnum(*lab);
  848.     eatup();
  849.     outdon();
  850. }
  851.  
  852. /*
  853.  * dostat - generate code for end of do statement
  854.  *
  855.  */
  856. dostat(lab)
  857. int lab;
  858. {
  859.     outcon(lab);
  860.     outcon(lab+1);
  861. }
  862.  
  863. /*
  864.  * elseif - generate code for end of if before else
  865.  *
  866.  */
  867. elseif(lab)
  868. int lab;
  869. {
  870.  
  871.     outgo(lab+1);
  872.     outcon(lab);
  873. }
  874.  
  875. /*
  876.  * forcod - beginning of for statement
  877.  *
  878.  */
  879. forcod(lab)
  880. int *lab;
  881. {
  882.     char t, token[MAXTOK];
  883.     int i, j, nlpar,tlab;
  884.  
  885.     tlab = *lab;
  886.     tlab = labgen(3);
  887.     outcon(0);
  888.     if (gnbtok(token, MAXTOK) != LPAREN) {
  889.         synerr("missing left paren.");
  890.         return;
  891.     }
  892.     if (gnbtok(token, MAXTOK) != SEMICOL) {   /* real init clause */
  893.         pbstr(token);
  894.         outtab();
  895.         eatup();
  896.         outdon();
  897.     }
  898.     if (gnbtok(token, MAXTOK) == SEMICOL)   /* empty condition */
  899.         outcon(tlab);
  900.     else {   /* non-empty condition */
  901.         pbstr(token);
  902.         outnum(tlab);
  903.         outtab();
  904.         outstr(ifnot);
  905.         outch(LPAREN);
  906.         nlpar = 0;
  907.         while (nlpar >= 0) {
  908.             t = gettok(token, MAXTOK);
  909.             if (t == SEMICOL)
  910.                 break;
  911.             if (t == LPAREN)
  912.                 nlpar++;
  913.             else if (t == RPAREN)
  914.                 nlpar--;
  915.             if (t == EOF) {
  916.                 pbstr(token);
  917.                 return;
  918.             }
  919.             if (t != NEWLINE && t != UNDERLINE)
  920.                 outstr(token);
  921.         }
  922.         outch(RPAREN);
  923.         outch(RPAREN);
  924.         outgo((tlab)+2);
  925.         if (nlpar < 0)
  926.             synerr("invalid for clause.");
  927.     }
  928.     fordep++;               /* stack reinit clause */
  929.     j = 0;
  930.     for (i = 1; i < fordep; i++)   /* find end *** should i = 1 ??? *** */
  931.         j = j + strlen(&forstk[j]) + 1;
  932.     forstk[j] = EOS;   /* null, in case no reinit */
  933.     nlpar = 0;
  934.     t = gnbtok(token, MAXTOK);
  935.     pbstr(token);
  936.     while (nlpar >= 0) {
  937.         t = gettok(token, MAXTOK);
  938.         if (t == LPAREN)
  939.             nlpar++;
  940.         else if (t == RPAREN)
  941.             nlpar--;
  942.         if (t == EOF) {
  943.             pbstr(token);
  944.             break;
  945.         }
  946.         if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
  947.             if (j + strlen(token) >= MAXFORSTK)
  948.                 baderr("for clause too long.");
  949.             scopy(token, 0, forstk, j);
  950.             j = j + strlen(token);
  951.         }
  952.     }
  953.     tlab++;   /* label for next's */
  954.     *lab = tlab;
  955. }
  956.  
  957. /*
  958.  * fors - process end of for statement
  959.  *
  960.  */
  961. fors(lab)
  962. int lab;
  963. {
  964.     int i, j;
  965.  
  966.     xfer = NO;
  967.     outnum(lab);
  968.     j = 0;
  969.     for (i = 1; i < fordep; i++)
  970.         j = j + strlen(&forstk[j]) + 1;
  971.     if (strlen(&forstk[j]) > 0) {
  972.         outtab();
  973.         outstr(&forstk[j]);
  974.         outdon();
  975.     }
  976.     outgo(lab-1);
  977.     outcon(lab+1);
  978.     fordep--;
  979. }
  980.  
  981. /*
  982.  * ifcode - generate initial code for if
  983.  *
  984.  */
  985. ifcode(lab)
  986. int *lab;
  987. {
  988.  
  989.     xfer = NO;
  990.     *lab = labgen(2);
  991.     ifgo(*lab);
  992. }
  993.  
  994. /*
  995.  * ifgo - generate "if(.not.(...))goto lab"
  996.  *
  997.  */
  998. ifgo(lab)
  999. int lab;
  1000. {
  1001.  
  1002.     outtab();      /* get to column 7 */
  1003.     outstr(ifnot);      /* " if(.not. " */
  1004.     balpar();      /* collect and output condition */
  1005.     outch(RPAREN);      /* " ) " */
  1006.     outgo(lab);         /* " goto lab " */
  1007. }
  1008.  
  1009.  
  1010. /*
  1011.  * labelc - output statement number
  1012.  *
  1013.  */
  1014. labelc(lexstr)
  1015. char lexstr[];
  1016. {
  1017.  
  1018.     xfer = NO;   /* can't suppress goto's now */
  1019.     if (strlen(lexstr) == 5)   /* warn about 23xxx labels */
  1020.         if (lexstr[0] == DIG2 && lexstr[1] == DIG3)
  1021.             synerr("warning: possible label conflict.");
  1022.     outstr(lexstr);
  1023.     outtab();
  1024. }
  1025.  
  1026. /*
  1027.  * labgen - generate  n  consecutive labels, return first one
  1028.  *
  1029.  */
  1030. int
  1031. labgen(n)
  1032. int n;
  1033. {
  1034.     int i;
  1035.  
  1036.     i = label;
  1037.     label = label + n;
  1038.     return(i);
  1039. }
  1040.  
  1041. /*
  1042.  * otherc - output ordinary Fortran statement
  1043.  *
  1044.  */
  1045. otherc(lexstr)
  1046. char lexstr[];
  1047. {
  1048.     xfer = NO;
  1049.     outtab();
  1050.     outstr(lexstr);
  1051.     eatup();
  1052.     outdon();
  1053. }
  1054.  
  1055. /*
  1056.  * outch - put one char into output buffer
  1057.  *
  1058.  */
  1059. outch(c)
  1060. char c;
  1061. {
  1062.     int i;
  1063.  
  1064.     if (outp >= 72) {   /* continuation card */
  1065.         outdon();
  1066.         /*** should output "-" for dcl continuation.. ***/
  1067.         for (i = 0; i < 6; i++)
  1068.             outbuf[i] = BLANK;
  1069.         outp = 6;
  1070.     }
  1071.     outbuf[outp] = c;
  1072.     outp++;
  1073. }
  1074.  
  1075. /*
  1076.  * outcon - output "n   continue"
  1077.  *
  1078.  */
  1079. outcon(n)
  1080. int n;
  1081. {
  1082.     xfer = NO;
  1083.     if (n <= 0 && outp == 0)
  1084.         return;            /* don't need unlabeled continues */
  1085.     if (n > 0)
  1086.         outnum(n);
  1087.     outtab();
  1088.     outstr(contin);
  1089.     outdon();
  1090. }
  1091.  
  1092. /*
  1093.  * outdon - finish off an output line
  1094.  *
  1095.  */
  1096. outdon()
  1097. {
  1098.  
  1099.     outbuf[outp] = NEWLINE;
  1100.     outbuf[outp+1] = EOS;
  1101.     printf(outbuf);
  1102.     outp = 0;
  1103. }
  1104.  
  1105. /*
  1106.  * outgo - output "goto  n"
  1107.  *
  1108.  */
  1109. outgo(n)
  1110. int n;
  1111. {
  1112.     if (xfer == YES)
  1113.         return;
  1114.     outtab();
  1115.     outstr(rgoto);
  1116.     outnum(n);
  1117.     outdon();
  1118. }
  1119.  
  1120. /*
  1121.  * outnum - output positive decimal number
  1122.  *
  1123.  */
  1124. outnum(n)
  1125. int n;
  1126. {
  1127.  
  1128.     char chars[MAXCHARS];
  1129.     int i, m;
  1130.  
  1131.     m = n;
  1132.     i = -1;
  1133.     do {
  1134.         i++;
  1135.         chars[i] = (m % 10) + DIG0;
  1136.         m = m / 10;
  1137.     } 
  1138.     while (m > 0 && i < MAXCHARS);
  1139.     for ( ; i >= 0; i--)
  1140.         outch(chars[i]);
  1141. }
  1142.  
  1143.  
  1144.  
  1145. /*
  1146.  * outstr - output string
  1147.  *
  1148.  */
  1149. outstr(str)
  1150. char str[];
  1151. {
  1152.     int i;
  1153.  
  1154.     for (i=0; str[i] != EOS; i++)
  1155.         outch(str[i]);
  1156. }
  1157.  
  1158. /*
  1159.  * outtab - get past column 6
  1160.  *
  1161.  */
  1162. outtab()
  1163. {
  1164.     while (outp < 6)
  1165.         outch(BLANK);
  1166. }
  1167.  
  1168.  
  1169. /*
  1170.  * repcod - generate code for beginning of repeat
  1171.  *
  1172.  */
  1173. repcod(lab)
  1174. int *lab;
  1175. {
  1176.  
  1177.     int tlab;
  1178.  
  1179.     tlab = *lab;
  1180.     outcon(0);   /* in case there was a label */
  1181.     tlab = labgen(3);
  1182.     outcon(tlab);
  1183.     *lab = ++tlab;          /* label to go on next's */
  1184. }
  1185.  
  1186. /*
  1187.  * retcod - generate code for return
  1188.  *
  1189.  */
  1190. retcod()
  1191. {
  1192.     char token[MAXTOK], t;
  1193.  
  1194.     t = gnbtok(token, MAXTOK);
  1195.     if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
  1196.         pbstr(token);
  1197.         outtab();
  1198.         outstr(fcname);
  1199.         outch(EQUALS);
  1200.         eatup();
  1201.         outdon();
  1202.     }
  1203.     else if (t == RBRACE)
  1204.         pbstr(token);
  1205.     outtab();
  1206.     outstr(sret);
  1207.     outdon();
  1208.     xfer = YES;
  1209. }
  1210.  
  1211.  
  1212. /* strdcl - generate code for string declaration */
  1213. strdcl()
  1214. {
  1215.     char t, name[MAXNAME], init[MAXTOK];
  1216.     int i, len;
  1217.  
  1218.     t = gnbtok(name, MAXNAME);
  1219.     if (t != ALPHA)
  1220.         synerr("missing string name.");
  1221.     if (gnbtok(init, MAXTOK) != LPAREN) {  /* make size same as initial value */
  1222.         len = strlen(init) + 1;
  1223.         if (init[1] == SQUOTE || init[1] == DQUOTE)
  1224.             len = len - 2;
  1225.     }
  1226.     else {  /* form is string name(size) init */
  1227.         t = gnbtok(init, MAXTOK);
  1228.         i = 0;
  1229.         len = ctoi(init, &i);
  1230.         if (init[i] != EOS)
  1231.             synerr("invalid string size.");
  1232.         if (gnbtok(init, MAXTOK) != RPAREN)
  1233.             synerr("missing right paren.");
  1234.         else
  1235.             t = gnbtok(init, MAXTOK);
  1236.     }
  1237.     outtab();
  1238.     /*
  1239.         *   outstr(int);
  1240.         */
  1241.     outstr(name);
  1242.     outch(LPAREN);
  1243.     outnum(len);
  1244.     outch(RPAREN);
  1245.     outdon();
  1246.     outtab();
  1247.     outstr(dat);
  1248.     len = strlen(init) + 1;
  1249.     if (init[0] == SQUOTE || init[0] == DQUOTE) {
  1250.         init[len-1] = EOS;
  1251.         scopy(init, 1, init, 0);
  1252.         len = len - 2;
  1253.     }
  1254.     for (i = 1; i <= len; i++) {    /* put out variable names */
  1255.         outstr(name);
  1256.         outch(LPAREN);
  1257.         outnum(i);
  1258.         outch(RPAREN);
  1259.         if (i < len)
  1260.             outch(COMMA);
  1261.         else
  1262.             outch(SLASH);
  1263.         ;
  1264.     }
  1265.     for (i = 0; init[i] != EOS; i++) {      /* put out init */
  1266.         outnum(init[i]);
  1267.         outch(COMMA);
  1268.     }
  1269.     pbstr(eoss);    /* push back EOS for subsequent substitution */
  1270. }
  1271.  
  1272.  
  1273. /*
  1274.  * unstak - unstack at end of statement
  1275.  *
  1276.  */
  1277. unstak(sp, lextyp, labval, token)
  1278. int *sp;
  1279. int lextyp[];
  1280. int labval[];
  1281. char token;
  1282. {
  1283.     int tp;
  1284.  
  1285.     tp = *sp;
  1286.     for ( ; tp > 0; tp--) {
  1287.         if (lextyp[tp] == LBRACE)
  1288.             break;
  1289.         if (lextyp[tp] == LEXIF && token == LEXELSE)
  1290.             break;
  1291.         if (lextyp[tp] == LEXIF)
  1292.             outcon(labval[tp]);
  1293.         else if (lextyp[tp] == LEXELSE) {
  1294.             if (*sp > 1)
  1295.                 tp--;
  1296.             outcon(labval[tp]+1);
  1297.         }
  1298.         else if (lextyp[tp] == LEXDO)
  1299.             dostat(labval[tp]);
  1300.         else if (lextyp[tp] == LEXWHILE)
  1301.             whiles(labval[tp]);
  1302.         else if (lextyp[tp] == LEXFOR)
  1303.             fors(labval[tp]);
  1304.         else if (lextyp[tp] == LEXREPEAT)
  1305.             untils(labval[tp], token);
  1306.     }
  1307.     *sp = tp;
  1308. }
  1309.  
  1310. /*
  1311.  * untils - generate code for until or end of repeat
  1312.  *
  1313.  */
  1314. untils(lab, token)
  1315. int lab;
  1316. int token;
  1317. {
  1318.     char ptoken[MAXTOK];
  1319.  
  1320.     xfer = NO;
  1321.     outnum(lab);
  1322.     if (token == LEXUNTIL) {
  1323.         lex(ptoken);
  1324.         ifgo(lab-1);
  1325.     }
  1326.     else
  1327.         outgo(lab-1);
  1328.     outcon(lab+1);
  1329. }
  1330.  
  1331. /* 
  1332.  * whilec - generate code for beginning of while 
  1333.  *
  1334.  */
  1335. whilec(lab)
  1336. int *lab;
  1337. {
  1338.     int tlab;
  1339.  
  1340.     tlab = *lab;
  1341.     outcon(0);         /* unlabeled continue, in case there was a label */
  1342.     tlab = labgen(2);
  1343.     outnum(tlab);
  1344.     ifgo(tlab+1);
  1345.     *lab = tlab;
  1346. }
  1347.  
  1348. /* 
  1349.  * whiles - generate code for end of while 
  1350.  *
  1351.  */
  1352. whiles(lab)
  1353. int lab;
  1354. {
  1355.  
  1356.     outgo(lab);
  1357.     outcon(lab+1);
  1358. }
  1359.  
  1360.  
  1361. /* ------------------------------ */
  1362. /* E R R O R  M E S S A G E S     */
  1363. /* ------------------------------ */
  1364.  
  1365. /*
  1366.  *  baderr - print error message, then die
  1367.  *
  1368.  */
  1369. baderr(msg)
  1370. char msg[];
  1371. {
  1372.     synerr(msg);
  1373.     exit(1);
  1374. }
  1375.  
  1376.  
  1377. /* 
  1378.  * synerr - report Ratfor syntax error
  1379.  *
  1380.  */
  1381. synerr(msg)
  1382. char msg[];
  1383. {
  1384.     char lc[MAXCHARS];
  1385.     int i;
  1386.  
  1387.     fprintf(stderr,errmsg);
  1388.     if (level >= 0)
  1389.         i = level;
  1390.     else
  1391.         i = 0;   /* for EOF errors */
  1392.     itoc(linect[i], lc, MAXCHARS);
  1393.     fprintf(stderr,lc);
  1394.     for (i = fnamp - 1; i > 1; i = i - 1)
  1395.         if (fnames[i-1] == EOS) {   /* print file name */
  1396.             fprintf(stderr,in);
  1397.             fprintf(stderr,fnames[i]);
  1398.             break;
  1399.         }
  1400.     fprintf(stderr,": \n      %s\n",msg);
  1401. }
  1402.  
  1403. /*
  1404.  * usage
  1405.  *
  1406.  */
  1407. usage()
  1408. {
  1409.     fprintf(stderr,"usage: ratfor <input file> [output file]\n");
  1410.     exit(1);
  1411. }
  1412.  
  1413.  
  1414. /* ------------------------------ */
  1415. /* U T I L I T Y  R O U T I N E S */
  1416. /* ------------------------------ */
  1417.  
  1418. /*
  1419.  * ctoi - convert string at in[i] to int, increment i
  1420.  *
  1421.  */
  1422. int
  1423. ctoi(in, i)
  1424. char in[];
  1425. int *i;
  1426. {
  1427.     int k, j;
  1428.  
  1429.     j = *i;
  1430.     while (in[j] == BLANK || in[j] == TAB)
  1431.         j++;
  1432.     for (k = 0; in[j] != EOS; j++) {
  1433.         if (in[j] < DIG0 || in[j] > DIG9)
  1434.             break;
  1435.         k = 10 * k + in[j] - DIG0;
  1436.     }
  1437.     *i = j;
  1438.     return(k);
  1439. }
  1440.  
  1441. /*
  1442.  * fold - convert alphabetic token to single case
  1443.  *
  1444.  */
  1445. fold(token)
  1446. char token[];
  1447. {
  1448.  
  1449.     int i;
  1450.  
  1451.     /* WARNING - this routine depends heavily on the */
  1452.     /* fact that letters have been mapped into internal */
  1453.     /* right-adjusted ascii. god help you if you */
  1454.     /* have subverted this mechanism. */
  1455.  
  1456.     for (i = 0; token[i] != EOS; i++)
  1457.         if (token[i] >= BIGA && token[i] <= BIGZ)
  1458.             token[i] = token[i] - BIGA + LETA;
  1459. }
  1460.  
  1461. /*
  1462.  * equal - compare str1 to str2; return YES if equal, NO if not
  1463.  *
  1464.  */
  1465. int
  1466. equal(str1, str2)
  1467. char str1[];
  1468. char str2[];
  1469. {
  1470.     int i;
  1471.  
  1472.     for (i = 0; str1[i] == str2[i]; i++)
  1473.         if (str1[i] == EOS) {
  1474.             return(YES);
  1475.         }
  1476.     return(NO);
  1477. }
  1478.  
  1479. /*
  1480.  * scopy - copy string at from[i] to to[j]
  1481.  *
  1482.  */
  1483. scopy(from, i, to, j)
  1484. char from[];
  1485. int i;
  1486. char to[];
  1487. int j;
  1488. {
  1489.     int k1, k2;
  1490.  
  1491.     k2 = j;
  1492.     for (k1 = i; from[k1] != EOS; k1++) {
  1493.         to[k2] = from[k1];
  1494.         k2++;
  1495.     }
  1496.     to[k2] = EOS;
  1497. }
  1498.  
  1499. #include "\c86\include\lookup.h"
  1500. /*
  1501.  * look - look-up a definition
  1502.  *
  1503.  */
  1504. int
  1505. look(name,defn)
  1506. char name[];
  1507. char defn[];
  1508. {
  1509.     extern struct hashlist *lookup();
  1510.     struct hashlist *p;
  1511.  
  1512.     if ((p = lookup(name)) == NULL)
  1513.         return(NO);
  1514.     strcpy(defn,p->def);
  1515.     return(YES);
  1516. }
  1517.  
  1518. /*
  1519.  * itoc - special version of itoa
  1520.  *
  1521.  */
  1522. int
  1523. itoc(n,str,size)
  1524. int n;
  1525. char str[];
  1526. int size;
  1527. {
  1528.  
  1529.     int i,j,k,sign;
  1530.     char c;
  1531.  
  1532.     if ((sign = n) < 0)
  1533.         n = -n;
  1534.     i = 0;
  1535.     do {
  1536.         str[i++] = n % 10 + '0'; 
  1537.     } 
  1538.     while ((n /= 10) > 0 && i < size-2);
  1539.     if (sign < 0 && i < size-1)
  1540.         str[i++] = '-';
  1541.     str[i] = EOS;
  1542.     /*
  1543.          * reverse the string and plug it back in
  1544.          *
  1545.          */
  1546.     for (j = 0, k = strlen(str) - 1; j < k; j++, k--) {
  1547.         c = str[j];
  1548.         str[j] = str[k];
  1549.         str[k] = c;
  1550.     }
  1551.     return(i-1);
  1552. }